home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2006 December / PCWDEC06.iso / Software / Trial / Paint Shop Pro XI / Data1.cab / unixfile.tcl.0160FC08_F3D9_4869_9D41_C611C16F42D5 < prev    next >
Encoding:
Text File  |  2005-06-08  |  8.2 KB  |  413 lines
  1. # -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
  2. #
  3. #    $Id: UnixFile.tcl,v 1.4.2.1 2001/11/03 07:25:12 idiscovery Exp $
  4. #
  5. # UnixFile.tcl --
  6. #
  7. #    Unix file access portibility routines.
  8. #
  9. # Copyright (c) 1993-1999 Ioi Kim Lam.
  10. # Copyright (c) 2000-2001 Tix Project Group.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14. #
  15.  
  16. proc tixInitFileCmpt:Unix {} {
  17.  
  18. # tixFSSplit --
  19. # 
  20. # Splits a directory into its hierarchical components
  21. #
  22. # "hlist-type hierachical path"        <- "vpath"
  23. # "name"
  24. # "directory name"            <- "path"
  25. #
  26. proc tixFSSplit {dir} {
  27.     if {[string compare [tixFSPathType $dir] "absolute"]} {
  28.     error "$dir must be an absolute path"
  29.     }
  30.  
  31.     set path ""
  32.     set p ""
  33.     foreach d [tixFileSplit $dir] {
  34.     set p [tixFSJoin $p $d]
  35.     lappend path [list $p $d $p]
  36.     }
  37.     return $path
  38. }
  39.  
  40. # returns true if $dir is an valid path (always true in Unix)
  41. #
  42. proc tixFSValid {dir} {
  43.     return 1
  44. }
  45.  
  46. # Directory separator
  47. #
  48. proc tixFSSep {} {
  49.     return "/"
  50. }
  51.  
  52. # tixFSIntName
  53. #
  54. #    Returns the "virtual path" of a filename
  55. #
  56. proc tixFSIntName {dir} {
  57.     if {[string compare [tixFSPathType $dir] "absolute"]} {
  58.     error "$dir must be an absolute path"
  59.     }
  60.  
  61.     return $dir
  62. }
  63.  
  64. proc tixFSResolveName {p} {
  65.     return $p
  66. }
  67.  
  68.  
  69. # These subcommands of "file" only exist in Tcl 7.5+. We define the following
  70. # wrappers so that the code also works under Tcl 7.4
  71. #
  72. global tcl_version
  73. if {![string compare $tcl_version 7.4]} {
  74.  
  75.     proc tixFSPathType {dir} {
  76.     if {![string compare [string index $dir 0] /]} {
  77.         return "absolute"
  78.     }
  79.     if {![string compare [string index $dir 0] ~]} {
  80.         return "absolute"
  81.     }
  82.     return "relative"
  83.     }
  84.  
  85.     proc tixFSJoin {dir sub} {
  86.     set joined $dir/$sub
  87.  
  88.     regsub -all {[/]+} $joined / joined
  89.     return $joined
  90.     }
  91.  
  92. } else {
  93.     proc tixFSPathType {dir} {
  94.     return [file pathtype $dir]
  95.     }
  96.  
  97.     proc tixFSJoin {dir sub} {
  98.     return [file join $dir $sub]
  99.     }
  100. }
  101.  
  102. # dir:        Make a listing of this directory
  103. # showSubDir:    Want to list the subdirectories?
  104. # showFile:    Want to list the non-directory files in this directory?
  105. # showPrevDir:    Want to list ".." as well?
  106. # showHidden:    Want to list the hidden files?
  107. #
  108. # return value:    a list of files and/or subdirectories
  109. #
  110. proc tixFSListDir {dir showSubDir showFile showPrevDir showHidden {pattern ""}} {
  111.     set appPWD [pwd]
  112.  
  113.     if {[catch {cd $dir} err]} {
  114.     # The user has entered an invalid directory
  115.     # %% todo: prompt error, go back to last succeed directory
  116.     cd $appPWD
  117.     return ""
  118.     }
  119.  
  120.     if {$pattern == ""} {
  121.     if $showHidden {
  122.         set pattern "* .*"
  123.     } else {
  124.         set pattern *
  125.     }
  126.     } elseif {$pattern == "*"} {
  127.     if $showHidden {
  128.         set pattern "* .*"
  129.     }
  130.     }
  131.  
  132.     set list ""
  133.     foreach pat $pattern {
  134.     if {[catch {set names [lsort [glob -nocomplain $pat]]} err]} {
  135.         # Cannot read directory
  136.         # %% todo: show directory permission denied
  137.         continue
  138.     }
  139.  
  140.     catch {
  141.         # We are catch'ing, just in case the "file" command
  142.         # returns unexpected errors
  143.         #
  144.         foreach fname $names {
  145.         if {![string compare . $fname]} {
  146.             continue
  147.         }
  148.         if {[file isdirectory $fname]} {
  149.             if {![string compare ".." $fname] && !$showPrevDir} {
  150.             continue
  151.             }
  152.             if $showSubDir {
  153.             lappend list [file tail $fname]
  154.             }
  155.         } else {
  156.             if $showFile {
  157.             lappend list [file tail $fname]
  158.             }
  159.         }
  160.         }
  161.     }
  162.     }
  163.  
  164.     cd $appPWD
  165.  
  166.     if {[llength $pattern] > 1} {
  167.     # get rid of duplicated names
  168.     #
  169.     set list1 ""
  170.     set oldfile ""
  171.     foreach name [lsort $list] {
  172.         if {$name == $oldfile} {
  173.         continue
  174.         }
  175.         lappend list1 $name
  176.         set oldfile $name
  177.     }
  178.     return [_tixFSMakeList $dir $list1]
  179.     } else {
  180.     return [_tixFSMakeList $dir $list]
  181.     }
  182. }
  183.  
  184. # _tixFSMakeList -
  185. #
  186. #    Internal procedure. Used only by tixFSListDir
  187. proc _tixFSMakeList {dir list} {
  188.     set l ""
  189.     foreach file $list {
  190.     set path [tixFSJoin $dir $file]
  191.     lappend l [list $path $file $path]
  192.     }
  193.  
  194.     return $l
  195. }
  196.  
  197. # Directory separator
  198. #
  199. proc tixDirSep {} {
  200.     return "/"
  201. }
  202.  
  203.  
  204. # tixFSInfo --
  205. #
  206. #    Returns information about the file system of this OS
  207. #
  208. # hasdrives: Boolean
  209. #    Does this file system support seperate disk drives?
  210. #
  211. proc tixFSInfo {args} {
  212.     case [lindex $args 0] {
  213.     hasdrives {
  214.         return 0
  215.     }
  216.     }
  217. }
  218.  
  219. #----------------------------------------------------------------------
  220. # Obsolete
  221. #----------------------------------------------------------------------
  222.  
  223. # nativeName:    native filename used in this OS, comes from the user or
  224. #        application programmer
  225. # defParent:    if the filename is not an absolute path, treat it as a
  226. #        subfolder of $defParent
  227. proc tixFileIntName {nativeName {defParent ""}} {
  228.     if {![tixIsAbsPath $nativeName]} {
  229.     if {$defParent != ""} {
  230.         set path [tixSubFolder $defParent $nativeName]
  231.     } else {
  232.         set path $nativeName
  233.     }
  234.     } else {
  235.     set path $nativeName
  236.     }
  237.  
  238.     set intName ""
  239.     set path [tixFile trimslash [tixFile tildesubst $path]]
  240.     foreach name [tixFileSplit $path] {
  241.     set intName [tixSubFolder $intName $name]
  242.     }
  243.     return $intName
  244. }
  245.  
  246. proc tixNativeName {name {mustBeAbs ""}} {
  247.     return $name
  248. }
  249.  
  250. proc tixFileDisplayName {intName} {
  251.     if {$intName == "/"} {
  252.     return "/"
  253.     } else {
  254.     return [file tail $intName]
  255.     }
  256. }
  257.  
  258.  
  259. proc tixFileSplit {intName} {
  260.  
  261.     set l ""
  262.     foreach n [split $intName /] {
  263.     if {$n == ""} {
  264.         continue
  265.     }
  266.     if {$n == "."} {
  267.         continue
  268.     }
  269.  
  270.     lappend l $n
  271.     }
  272.     
  273.  
  274.     while {1} {
  275.     set idx [lsearch $l ".."]
  276.     if {$idx == -1} {
  277.         break;
  278.     }
  279.     set l [lreplace $l [expr $idx -1] $idx]
  280.     }
  281.  
  282.  
  283.     if {[string index $intName 0] == "/"} {
  284.     return [concat "/" $l]
  285.     } else {
  286.     return $l
  287.     }
  288. }
  289.  
  290. proc tixSubFolder {parent sub} {
  291.     if {$parent == ""} {
  292.     return $sub
  293.     }
  294.     if {$parent == "/"} {
  295.     return /$sub
  296.     } else {
  297.     return $parent/$sub
  298.     }
  299. }
  300.  
  301. # dir:        Make a listing of this directory
  302. # showSubDir:    Want to list the subdirectories?
  303. # showFile:    Want to list the non-directory files in this directory?
  304. # showPrevDir:    Want to list ".." as well?
  305. # showHidden:    Want to list the hidden files?
  306. #
  307. # return value:    a list of files and/or subdirectories
  308. #
  309. proc tixListDir {dir showSubDir showFile showPrevDir showHidden {pattern ""}} { 
  310.  
  311.     set appPWD [pwd]
  312.  
  313.     if {[catch {cd $dir} err]} {
  314.     # The user has entered an invalid directory
  315.     # %% todo: prompt error, go back to last succeed directory
  316.     cd $appPWD
  317.     return ""
  318.     }
  319.  
  320.     if {$pattern == ""} {
  321.     if $showHidden {
  322.         set pattern "* .*"
  323.     } else {
  324.         set pattern *
  325.     }
  326.     } elseif {$pattern == "*"} {
  327.     if $showHidden {
  328.         set pattern "* .*"
  329.     }
  330.     }
  331.  
  332.     set list ""
  333.     foreach pat $pattern {
  334.     if {[catch {set names [lsort [glob -nocomplain $pat]]} err]} {
  335.         # Cannot read directory
  336.         # %% todo: show directory permission denied
  337.         continue
  338.     }
  339.  
  340.     catch {
  341.         # We are catch'ing, just in case the "file" command
  342.         # returns unexpected errors
  343.         #
  344.         foreach fname $names {
  345.         if {![string compare . $fname]} {
  346.             continue
  347.         }
  348.         if {[file isdirectory $fname]} {
  349.             if {![string compare ".." $fname] && !$showPrevDir} {
  350.             continue
  351.             }
  352.             if $showSubDir {
  353.             lappend list [file tail $fname]
  354.             }
  355.         } else {
  356.             if $showFile {
  357.             lappend list [file tail $fname]
  358.             }
  359.         }
  360.         }
  361.     }
  362.     }
  363.  
  364.     cd $appPWD
  365.  
  366.     if {[llength $pattern] > 1} {
  367.     set list1 ""
  368.     set oldfile ""
  369.     foreach name [lsort $list] {
  370.         if {$name == $oldfile} {
  371.         continue
  372.         }
  373.         lappend list1 $name
  374.         set oldfile $name
  375.     }
  376.     return $list1
  377.     } else {
  378.     return $list
  379.     }
  380. }
  381.  
  382. # returns the "root directory" of this operating system
  383. #
  384. proc tixRootDir {} {
  385.     return "/"
  386. }
  387.  
  388. proc tixIsAbsPath {nativeName} {
  389.     set c [string index $nativeName 0]
  390.     if {$c == "~" || $c == "/"} {
  391.     return 1
  392.     } else {
  393.     return 0
  394.     }
  395. }
  396.  
  397. proc tixVerifyFile {file} {
  398.     return [tixFileIntName $file]
  399. }
  400.  
  401. proc tixFilePattern {args} {
  402.     if {[lsearch $args allFiles] != -1} {
  403.     return *
  404.     }
  405.     return *
  406. }
  407. }
  408.  
  409.  
  410.  
  411.  
  412.  
  413.